perm filename SETLET.F4[MSS,LCS]1 blob sn#075932 filedate 1974-03-19 generic text, type T, neo UTF8
00001	C  SUBRS.  SETLET, SETNUM
00002	
00010		SUBROUTINE SETLET
00015		DIMENSION RPOS(2,40),R(8,100)
00020		COMMON/SCM/V(78),Y,LCNT,STAFF,JLIST(200),REND
00030		COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
00053		COMMON/PTR/PWDS(250),ITEM,L,I,IX /XRN/RN(4000)
00090		COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
00095		EQUIVALENCE(RPOS,RN(3921)),(JF,JQ(4)),(R,RN(3001))
00100		M=1
00110		RPOS(1,1)=0
00200		DO 1 K=1,ITEM
00400		IF(FINDIT(K))GO TO 1
00500	C SKIPS NON-NOTES AND WRONG STAFF
00600		M=M+1
00700		RPOS(1,M)=RN(L+2)
00800	CC	RPOS(2,M)=L
00900	1	CONTINUE
00905		CALL SETNUM
01000		CALL SORT2(RPOS,M)
01010		K=2
01020	22	IF(RPOS(1,K).NE.RPOS(1,K-1))GO TO 2
01025		M=M-1
01030		DO 20 J=K,M
01040	20	RPOS(1,J)=RPOS(1,J+1)
01045	C  DELETES DOUBLE-STOPS - DOESN'T PUT NUM OVER 1ST NOTE.
01047		GO TO 22
01055	2	K=K+1
01057		IF(K.LT.M)GO TO 22
01103		DO 4 K=2,M
01150		JB=RHORZ(RPOS(1,K))
01200		CALL NOTWRT
01210		JF=JF+1
01220	4	IF(JF.EQ.10)JF=0
01330		CALL DPYOUT(3)
01340		CALL SETPOG(1)
01360		RPOS(1,M+1)=200
01370		J=1
01380		CALL TYPE
01390		REREAD F78F,V
01400		X=V(J)+1
01500		M=1
01600	3	K=X
01700		A=RPOS(1,K)
01800		B=RPOS(1,K+1)
01900		R(2,M)=A+(B-A)*(X-K)
01910		IF(R(4,M).NE.0)GO TO 5
02000		R(4,M)=V(J+1)
02100		J=J+2
02110		GO TO 6
02115	C IF P4≠0 TYPE ONLY 1 # FOR EACH ITEM. ALL ITEMS WILL BE AT VRT PS OF P4
02117	C TYPE Nn, Vert pos/Nn, Vert pos/  OR  Nn/Nn/ (if P4≠0)
02120	5	J=J+1
02180	6	M=M+1
02200		X=V(J)+1
02300		IF(X.GT.1)GO TO 3
02350	C CAN'T PUT LETTER AT POS. 0 *********
02400		END
02410	
02420		SUBROUTINE SETNUM
02520		DIMENSION SU(320)
02540		COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
02550		COMMON/POSI/STF(8),JJB,POS/DPY/ST(4000),WDS(250),MEDIT,IGO
02570		EQUIVALENCE (JC,JQ(1)),(JF,JQ(4)),(RJE,RJQ(3)),(RJD,RJQ(2))
02580		1,(SU(1),ST(3600))
02590		CALL DPYSET(3,SU,320)
02600		CALL DPYBRT(6)
02610		JF=1
02620	CC	RA=ST(1)
02630	CC	RJD=R(3,1)
02640		POS=STF(JC+4)
02650		RJD=18.
02660		JA=5
02670		RJE=1
02680		END